#Include "file.bi"
#Include "datetime.bi"
'
' CGI HELPER FUNCTIONS 
' (c) Yvan Janssens 2010
'     SOME RIGHTS RESERVED ;)
'

'Functions (finished):
Declare Function countOccurences(strHaystack As String, strChar As String) As Integer
Declare Function GetNthElement(Text As String, Delim As String = " " , ElementNumber As Integer) As String
Declare Function GetQueryString(strNameToSearch As String) As String
Declare Function Replace(strHaystack As String, strNeedle As String, strNewNeedle As String) As String
Declare Function ReadCookieValues(strNameToSearch As String) As String
Declare Function ReadCookie() As String
Declare Function URLEncode(strText As String) As String
Declare Sub AddCookieValue (strName As String, strValue As String)
Declare Function URLDecode(strText As String) As String
Declare Function NoHexNumber(strHex As String) As Integer
Declare Function TwoHexToInt(strHex As String) As Integer
Declare Function ConstructFileName (sessid As String) As String
Declare Function RandomString (numOfChars As Integer) As String
Declare Sub StartSession()
Declare Sub CleanUpSessions()
Declare Sub DestroySession()
Declare sub SetSessionVar(strName as string, strValue as string)
Declare Function ReadSessionVar(strName as string) as string
Declare Sub RuntimeError(strMessage as string, strTitle as string, strCode as string, stopExecution as integer = 0)
Declare Function GetSessionID() As String
Declare Function SafeCINT(strInvoer As String) As Integer
Declare Sub FillFormVariables()
Declare Sub Init()
Declare Function ReadFormValues (strFormName As String) As String


'Configuration Constants
Const SessionStorePath As String = "/tmp"
Const SessionFileSuffix As String = ".session_ycgi"

'Globals
Dim Shared strCookieToPrint As String
Dim Shared HeadersSend As Integer
Dim Shared strSESSION_ID As String
Dim Shared strFormVariables As String
Dim Shared intIsInitted As Integer

strSESSION_ID = ""
HeadersSend = 0
strCookieToPrint = ""
intIsInitted = 0
'actual code

'GetQueryString -- should be quite obviuos ;)
Function GetQueryString(strNameToSearch As String) As String
	Dim strQuerystring As String
	Dim strResult As String
	Dim strPair As String
	Dim intTeller As Integer
	Dim strName As String
	Dim strValue As String
	
	strResult = ""
	StrQuerystring = Environ$("QUERY_STRING")
	
	If strQuerystring = "" Then
		GetQueryString = ""
		Exit Function  
	EndIf
	
	If countOccurences(strQuerystring, "&") = 0 Then
		If GetNthElement(strQuerystring, "=", 0) = strNameToSearch Then
			GetQueryString = GetNthElement(strQuerystring, "=", 1)
		EndIf
		Exit Function
	EndIf
	
	For intTeller = 0 To countOccurences(strQuerystring, "&")
		
		strPair = GetNthElement(strQuerystring, "&", intTeller)
		strName = GetNthElement(strPair, "=", 0)
		strValue = GetNthElement(strPair, "=", 1)
		
		If strName = strNameToSearch Then
			strResult = strValue
			Exit For
		EndIf
	Next
	GetQueryString = strResult
End Function

'split - split a string into an array:

Function  GetNthElement(Text As String, Delim As String = " " , ElementNumber As Integer) As String
			If InStr(text, Delim) < 1 Then
				GetNthElement = ""
				Exit Function 
			EndIf
		  Dim Count As Long
		  Count = -1
		  Dim Ret(countOccurences(Text, Delim) ) As String
        Dim As Long x, p
        If Count < 1 Then
                Do 
                        x = Instr(x + 1, Text, Delim)
                        p += 1
                Loop Until x = 0
                Count = p - 1
        Elseif Count = 1 Then
                Redim Ret(Count)
                Ret(0) = Text
        Else
                Count -= 1
        End If
        Dim RetVal(Count) As Long
        x = 0
        p = 0
        Do Until p = Count
                x = Instr(x + 1,Text,Delim)
                RetVal(p) = x
                p += 1
        Loop
        Redim Ret(Count)
        Ret(0) = Left$(Text, RetVal(0) - 1 )
        p = 1
        Do Until p = Count
                Ret(p) = Mid$(Text, RetVal(p - 1) + 1, RetVal(p) - RetVal(p - 1) )
                p += 1
        Loop
        
        Ret(Count) = Mid$(Text, RetVal(Count - 1) + 1)
        
        GetNthElement = Replace(Ret(ElementNumber), delim, "")
End Function

Function countOccurences(strHaystack As String, strChar As String) As Integer
	Dim ret As Integer
	Dim x As Integer
	ret = 0
	For x = 1 To Len(strHayStack)
		If (Mid$(strHayStack, x, 1) = strChar) Then
			ret = ret + 1
		EndIf
	Next
	countOccurences = ret
End Function


Function Replace(strHaystack As String, strNeedle As String, strNewNeedle As String) As String
	Dim intPos As Integer
	Dim strRet As String
	
	strRet = ""
	For intPos = 0 To Len(strHaystack)
		If (Mid$(strHaystack, intPos, Len(strNeedle)) = strNeedle) Then
			strRet = strRet + strNewNeedle
			intPos = intPos + Len(strNeedle) - 1
		Else
			strRet = strRet + Mid$(strHaystack, intPos, 1)
		EndIf
	Next
	
	Replace = strRet
End Function

Function ReadCookie() As String
	ReadCookie =  Environ$("HTTP_COOKIE")
End Function

Function ReadCookieValues(strNameToSearch As String) As String
	Dim strQuerystring As String
	Dim strResult As String
	Dim strPair As String
	Dim intTeller As Integer
	Dim strName As String
	Dim strValue As String
	
	strResult = ""
	StrQuerystring = Environ$("HTTP_COOKIE")
	
	If strQuerystring = "" Then
		ReadCookieValues = ""
		Exit Function  
	EndIf
	
	If countOccurences(strQuerystring, "&") = 0 Then
		If GetNthElement(strQuerystring, "=", 0) = strNameToSearch Then
			ReadCookieValues = GetNthElement(strQuerystring, "=", 1)
		EndIf
		Exit Function
	EndIf
	
	For intTeller = 0 To countOccurences(strQuerystring, "&")
		
		strPair = GetNthElement(strQuerystring, "&", intTeller)
		strName = GetNthElement(strPair, "=", 0)
		strValue = GetNthElement(strPair, "=", 1)
		
		If strName = strNameToSearch Then
			strResult = strValue
			Exit For
		EndIf
	Next
	ReadCookieValues = URLDecode(strResult)
End Function

Sub EndHeaders (strContentType As String)
	If HeadersSend > 0 Then
		Return
	EndIf
	If strCookieToPrint = "" Then
	Else
		
		Print "Set-Cookie: " & strCookieToPrint & ";"
	EndIf
	Print "Content-Type: " & strContentType & ";"
	Print ""
	HeadersSend = 1
End Sub

Sub AddCookieValue (strName As String, strValue As String)
	If strCookieToPrint = "" Then
		strCookieToPrint = URLEncode(strName) & "=" & URLEncode(strValue)
	Else
		strCookieToPrint = strCookieToPrint & "&" & URLEncode(strName) & "=" & URLEncode(strValue)
	EndIf
End Sub

Function URLEncode(strText As String) As String
	Dim strOpzoekTabel(256) As String =	{ "", "%01", "%02", "%03", "%04", "%05", "%06", "%07", "%08", "%09",   "%0A", "%0B", "%0C", "%0D", "%0E", "%0F", "%10", "%11", "%12", "%13",   "%14", "%15", "%16", "%17", "%18", "%19", "%1A", "%1B", "%1C", "%1D",   "%1E", "%1F", "+",   "%21", "%22", "%23", "%24", "%25", "%26", "%27",   "%28", "%29", "",  "%2B", "%2C", "",  "",  "%2F", "",  "",   "",  "",  "",  "",  "",  "",  "",  "",  "%3A", "%3B",   "%3C", "%3D", "%3E", "%3F", "",  "",  "",  "",  "",  "",   "",  "",  "",  "",  "",  "",  "",  "",  "",  "",   "",  "",  "",  "",  "",  "",  "",  "",  "",  "",   "",  "%5B", "%5C", "%5D", "%5E", "",  "%60", "",  "",  "","",  "",  "",  "",  "",  "",  "",  "",  "",  "","",  "",  "",  "",  "",  "",  "",  "",  "",  "","",  "",  "",  "%7B", "%7C", "%7D", "%7E", "%7F", "%80", "%81","%82", "%83", "%84", "%85", "%86", "%87", "%88", "%89", "%8A", "%8B","%8C", "%8D", "%8E", "%8F", "%90", "%91", "%92", "%93", "%94", "%95","%96", "%97", "%98", "%99", "%9A", "%9B", "%9C", "%9D", "%9E", "%9F", "%A0", "%A1", "%A2", "%A3", "%A4", "%A5", "%A6", "%A7", "%A8", "%A9","%AA", "%AB", "%AC", "%AD", "%AE", "%AF", "%B0", "%B1", "%B2", "%B3","%B4", "%B5", "%B6", "%B7", "%B8", "%B9", "%BA", "%BB", "%BC", "%BD","%BE", "%BF", "%C0", "%C1", "%C2", "%C3", "%C4", "%C5", "%C6", "%C7","%C8", "%C9", "%CA", "%CB", "%CC", "%CD", "%CE", "%CF", "%D0", "%D1","%D2", "%D3", "%D4", "%D5", "%D6", "%D7", "%D8", "%D9", "%DA", "%DB","%DC", "%DD", "%DE", "%DF", "%E0", "%E1", "%E2", "%E3", "%E4", "%E5","%E6", "%E7", "%E8", "%E9", "%EA", "%EB", "%EC", "%ED", "%EE", "%EF","%F0", "%F1", "%F2", "%F3", "%F4", "%F5", "%F6", "%F7", "%F8", "%F9","%FA", "%FB", "%FC", "%FD", "%FE", "%FF"}
	Dim intPos As Integer
	Dim strResultaat As String
	
	strResultaat = ""
	
	For intPos = 1 To Len(strText)
		If (strOpzoekTabel(Asc(strText, intPos)) <> "" ) Then
			strResultaat = strResultaat & strOpzoekTabel(Asc(strText, intPos))
		Else
			strResultaat = strResultaat & Mid(strText, intPos, 1)
		EndIf
	Next
	
	URLEncode = strResultaat
	Exit Function 
End Function

Function URLDecode (strTekst As String) As String
	Dim intPositie As Integer
	Dim strResultaat As String
	Dim strTijdelijk As String
	Dim intCharCode As Integer
	
	strResultaat = ""
	strTijdelijk = ""
	intPositie = 1
	
	While intPositie <= Len(strTekst)
		
		Select Case Mid(strTekst, intPositie, 1)
			Case "%"
				'teken
				intPositie = intPositie + 1
				strTijdelijk = Mid(strTekst,intPositie, 2)
				intPositie = intPositie + 1
				intCharCode = TwoHexToInt(strTijdelijk)
				strResultaat = strResultaat + Chr$(intCharCode)
			Case "+"
				'spatie
				strResultaat = strResultaat & " "
			Case Else
				strResultaat = strResultaat + Mid(strTekst, intPositie, 1)	
		End Select
		intPositie = intPositie + 1	
	Wend
	URLDecode = strResultaat
End Function

Function NoHexNumber(strHex As String) As Integer
	Dim arrHexChars(15) As String => {"0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F"}
	Dim counter As Integer
	Dim counterHex As Integer
	Dim returnValue As Integer
	Dim tempValue As Integer
	returnValue = 0
	For counter = 1 To Len(strHex)
		tempValue = -1
		For counterHex = 0 To 15
			If (Mid(strHex, counter, 1) =arrHexChars(counterHex)) Then
				tempValue = counterHex
			EndIf
		Next
		If tempValue = -1 Then
			returnValue = 1
		EndIf
	Next
	NoHexNumber = returnValue
End Function

Function TwoHexToInt(strHex As String) As Integer
	Dim arrHexChars(15) As String => {"0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F"}
	Dim intResult As Integer
	Dim intCounter As Integer
	
	intResult = 0
	
	For intCounter = 0 To 15
		If (Mid(strHex, 2, 1) = arrHexChars(intCounter)) Then
			intResult = intResult + (intCounter * 1)
			Exit For
		EndIf
	Next
	
	For intCounter = 0 To 15
		If (Mid(strHex, 1, 1) = arrHexChars(intCounter)) Then
			intResult = intResult + (intCounter * 16)
			Exit For
		EndIf
	Next
	TwoHexToInt = intResult
End Function

Sub RuntimeError(strMessage as string, strTitle as string, strCode as string, stopExecution as Integer)
	If HeadersSend = 0 Then
		EndHeaders("text/html")
	EndIf
	If stopExecution > 0 Then
		Print "<!-- End All HTML Codes ---></TD></TD></TD></TH></TH></TH></TR></TR></TR></TABLE></TABLE></TABLE></A></ABBREV></ACRONYM></ADDRESS></APPLET></AU></B></BANNER></BIG></BLINK></BLOCKQUOTE></BQ></CAPTION></CENTER></CITE></CODE></COMMENT></DEL></DFN></DIR></DIV></DL></EM></FIG></FN></FONT></FORM></FRAME></FRAMESET></H1></H2></H3></H4></H5></H6></HEAD></I></INS></KBD></LISTING></MAP></MARQUEE></MENU></MULTICOL></NOBR></NOFRAMES></NOSCRIPT></NOTE></OL></P></PARAM></PERSON></PLAINTEXT></PRE></Q></S></SAMP></SCRIPT></SELECT></SMALL></STRIKE></STRONG></SUB></SUP></TABLE></TD></TEXTAREA></TH></TITLE></TR></TT></U></UL></VAR></WBR></XMP>"
	EndIf
	Print "<html>"
	Print "	<head><title>Runtime Error (" & strCode & ")</title><style type=""text/css"">.bodyfont {font-family: verdana;}</style></head>"
	Print "	<body>"
	Print "		<font style=""COLOR: black; FONT: 16pt/18pt verdana""> "
   Print " 			The web site you are accessing has experienced an unexpected runtime error.<br>" 
	Print "			Please contact the website administrator."
	Print "		"
   Print " 		</font>"
	Print ""
	Print "		<table border=""1"" bordercolor=""#990022"" class=""bodyfont"">"
	Print "			<tr>"
	Print "				<td bgcolor=""#990022"" style=""color:white;"">"
	Print "					Error while processing request"
	Print "				</td>"
	Print "			</tr>"
	Print "			<tr>"
	Print "				<td bgcolor=""990066"" style=""color:white"">"
	Print "					<h2>" & strTitle & "</h2>"
	Print "				</td>"
	Print "			</tr>"
	Print "			<tr>"
	Print "				<td>"
	Print "					" & Replace(strMessage,	Chr(10), "<br />")
	Print "				</td>"
	Print "			</tr>"
	Print "			<tr>"
	Print " 				<td bgcolor=""#990022"" style=""color:white;"">"
	Print "					<em>Error code: " & strCode & "</em>"
	Print "				</td>"
	Print "			</tr>"
	Print "		</table>"
	Print "		<br /><p><div align=""right""><em>&copy; 2010 YvanSoftware</em></div></p>"
	Print "	</body>"
	Print "</html>"
	If stopExecution > 0 Then
		End
	EndIf
End Sub

Function RandomString (numOfChars As Integer) As String
	Randomize Timer
	Dim sReturn As String
	Dim intTeller As Integer
	For intTeller = 1 To numOfChars
		sReturn = sReturn & Chr((Rnd() * 24 ) + 66)
	Next
	RandomString = sReturn
End Function

Sub StartSession()
	On Error GoTo Fout
	Dim strSessieID As String

	If GetSessionID() <> "" Then
		If FileExists(ConstructFileName(GetSessionID())) Then
			AddCookieValue("SessionID", GetSessionID())
			strSESSION_ID = GetSessionID()
			Exit sub
		EndIf
	EndIf	

	
	strSessieID = RandomString(64)
	strSESSION_ID = strSessieID
	'If HeadersSend <> 0 Then
	'	RuntimeError("Headers already sent - cannot start a new session." & Chr(10) & "The script will end.", "Headers already sent", "0x0001", 1)
	'EndIf
	
	If Open(ConstructFileName(strSessieID), For Output, As #1) <> 0 Then
		'session id already exists ?? WTF ???? Or cannot write to temp - ABORT!!
		RuntimeError("Internal Error: Temp File creation failure" & Chr(10) & "Make sure the temporary directory is writable.", "Server Failure", "0x0002", 1)
	EndIf
	
	Print #1, "CreationDate=" & URLEncode(Date())
	Close #1
	
	AddCookieValue("SessionID", strSessieID)
	
	CleanUpSessions()	
	
	Exit Sub
Fout:
 	RuntimeError ("Internal Error: Unknown", "Unknown error", "0x000D", 1)
End Sub

Function ConstructFileName (sessid As String) As String
	constructFileName = SessionStorePath & "/" & Replace(Replace(sessid,";",""),"%3D", "") & SessionFileSuffix
	'Print SessionStorePath & "/" & Replace(Replace(sessid,";",""),"%3D", "") & SessionFileSuffix
End Function

Sub CleanUpSessions()
	Dim strFilename As String
	Dim outAttr As Integer
	Dim d As Double
	
	strFilename = Dir(SessionStorePath & "/*." & SessionFileSuffix, , outAttr)
	Do Until strFilename = ""
		d = FileDateTime(strFileName)
		If ( d > DateAdd("h", -2, Now)) then
			Shell "rm """ & strFilename & """ > /dev/null"
		End If
		strFilename = Dir(outAttr)
	Loop
End Sub

Sub DestroySession()
	Dim strSessID As String
	strSessID = GetSessionID()
End Sub

Function ReadSessionVar(strName as string) as String

	Dim strSessID As String
	Dim strInvoer As String
	Dim strReturn As String
	Dim intFN As Integer
	strReturn = ""
	strSessID = GetSessionID()
	
	If strSessID = "" Then
		RuntimeError("You must first start a session before calling a session function.", "Session Error", "0x0003", 1)
	EndIf
	
	If FileExists(ConstructFileName(strSessID)) Then
		intFN = FreeFile()
		If Open(ConstructFileName(strSessID), For Input, As #intFN) = 0 Then
	
			Do Until Eof(intFN)
				Input #intFN, strInvoer
				If GetNthElement(strInvoer, "=", 0) = strName Then
					strReturn = Mid (strInvoer, InStr(strInvoer, "=") + 1)
					Exit Do
				EndIf
			Loop
			Close #intFN
		Else
			RuntimeError("Unable to open session file for input.", "Session Error", "0x0004", 1)
		EndIf
	Else
		StartSession()
	End If
	ReadSessionVar = strReturn
End Function

Sub SetSessionVar(strName as string, strValue as string)
	Dim strSessID As String
	Dim strNewSessionFile As String
	Dim strTemp As String
	strNewSessionFile = ""
	strSessId = GetSessionID()

	
	If strSessID <> "" Then	
		If ReadSessionVar(strName) <> "" Then
			If (Open(ConstructFileName(strSessId), FOR Input, As #1)) = 0 Then
				
				Do
					Input #1, strTemp
					If GetNthElement(strTemp, "=", 0) = strName Then
						strNewSessionFile = strNewSessionFile & strName & "=" & strValue & Chr(10) & Chr(13)
					Else
						strNewSessionFile = strNewSessionFile & strTemp & Chr(10) & Chr(13)
					EndIf
				Loop Until Eof(1)
				strNewSessionFile = Left (strNewSessionFile, Len (strNewSessionFile) - 2)
				Close #1
				If Open(ConstructFileName(strSessId), FOR OUTPUT, As #2) = 0 Then
					Print #2, strNewSessionFile
					Close #2
				EndIf
			EndIf
		Else
			If (Open(ConstructFileName(strSessId), FOR Append, As #3)) = 0 Then
				Print #3, strName & "=" & strValue
				Close #3
				
			EndIf

		EndIf
	Else

		StartSession()
		SetSessionVar(strName, strValue)
	EndIf
End Sub

Function GetSessionID() As String
	If ReadCookieValues("SessionID") = "" Then
		If strSESSION_ID <> "" Then
			GetSessionID = strSESSION_ID
		Else
			GetSessionID = ""
		EndIf
	Else
		GetSessionID = ReadCookieValues("SessionID")
	EndIf
End Function

Function SafeCINT(strInvoer As String) As Integer
	If strInvoer = "" Then
		SafeCINT = 0
		Exit Function
	EndIf
	If (UCase(strInvoer) = strInvoer) Then
		'no letters :)
		SafeCINT = CInt(strInvoer)
	Else
		Return 0
	EndIf
End Function

Sub Init()
	FillFormVariables
	intIsInitted = 1
End Sub

Sub FillFormVariables()
	 Input "", strFormVariables
End Sub

Function ReadFormValues (strNameToSearch As String) As String
	Dim strQuerystring As String
	Dim strResult As String
	Dim strPair As String
	Dim intTeller As Integer
	Dim strName As String
	Dim strValue As String
	
	strResult = ""
	StrQuerystring = strFormVariables
	
	If strQuerystring = "" Then
		ReadFormValues = ""
		Exit Function  
	EndIf
	
	If countOccurences(strQuerystring, "&") = 0 Then
		If GetNthElement(strQuerystring, "=", 0) = strNameToSearch Then
			ReadFormValues = URLDecode( GetNthElement(strQuerystring, "=", 1))
		EndIf
		Exit Function
	EndIf
	
	For intTeller = 0 To countOccurences(strQuerystring, "&")
		
		strPair = GetNthElement(strQuerystring, "&", intTeller)
		strName = GetNthElement(strPair, "=", 0)
		strValue = GetNthElement(strPair, "=", 1)
		
		If strName = strNameToSearch Then
			strResult = strValue
			Exit For
		EndIf
	Next
	Print strResult
	ReadFormValues = URLDecode(strResult)
End Function

'Test Code - erase and replace with ur own ;)
Init()
StartSession()
EndHeaders("text/html")
Dim intCounterPlus As Integer

intCounterPlus = CInt(ReadSessionVar("intCounter")) + 1
SetSessionVar("intCounter", str(intCounterPlus))
Print ReadSessionVar("intCounter")
Print ReadFormValues("azerty")
Print "<html><body><form action="""" method=""post""><input type=""text"" name=""azerty"" /><input type=""submit"" /></form></body></html>"
